home *** CD-ROM | disk | FTP | other *** search
/ Personal Computer World 2009 February / PCWFEB09.iso / Software / Linux / Kubuntu 8.10 / kubuntu-8.10-desktop-i386.iso / casper / filesystem.squashfs / usr / share / perl5 / Mail / Internet.pm < prev    next >
Text File  |  2008-05-03  |  12KB  |  551 lines
  1. # Copyrights 1995-2008 by Mark Overmeer <perl@overmeer.net>.
  2. #  For other contributors see ChangeLog.
  3. # See the manual pages for details on the licensing terms.
  4. # Pod stripped from pm file by OODoc 1.04.
  5. package Mail::Internet;
  6. use vars '$VERSION';
  7. $VERSION = '2.03';
  8. use strict;
  9. # use warnings?  probably breaking too much code
  10.  
  11. use Carp;
  12. use Mail::Header;
  13. use Mail::Util    qw/mailaddress/;
  14. use Mail::Address;
  15.  
  16.  
  17. sub new(@)
  18. {   my $call  = shift;
  19.     my $arg   = @_ % 2 ? shift : undef;
  20.     my %opt   = @_;
  21.  
  22.     my $class = ref($call) || $call;
  23.     my $self  = bless {}, $class;
  24.  
  25.     $self->{mail_inet_head} = $opt{Header} if exists $opt{Header};
  26.     $self->{mail_inet_body} = $opt{Body}   if exists $opt{Body};
  27.  
  28.     my $head = $self->head;
  29.     $head->fold_length(delete $opt{FoldLength} || 79);
  30.     $head->mail_from($opt{MailFrom}) if exists $opt{MailFrom};
  31.     $head->modify(exists $opt{Modify} ? $opt{Modify} : 1);
  32.  
  33.     if(!defined $arg) { }
  34.     elsif(ref($arg) eq 'ARRAY')
  35.     {   $self->header($arg) unless exists $opt{Header};
  36.         $self->body($arg)   unless exists $opt{Body};
  37.     }
  38.     elsif(defined fileno($arg))
  39.     {   $self->read_header($arg) unless exists $opt{Header};
  40.         $self->read_body($arg)   unless exists $opt{Body};
  41.     }
  42.     else
  43.     {   croak "couldn't understand $arg to Mail::Internet constructor";
  44.     }
  45.  
  46.     $self;
  47. }
  48.  
  49.  
  50. sub read(@)
  51. {   my $self = shift;
  52.     $self->read_header(@_);
  53.     $self->read_body(@_);
  54. }
  55.  
  56. sub read_body($)
  57. {   my ($self, $fd) = @_;
  58.     $self->body( [ <$fd> ] );
  59. }
  60.  
  61. sub read_header(@)
  62. {   my $head = shift->head;
  63.     $head->read(@_);
  64.     $head->header;
  65. }
  66.  
  67.  
  68. sub extract($)
  69. {   my ($self, $lines) = @_;
  70.     $self->head->extract($lines);
  71.     $self->body($lines);
  72. }
  73.  
  74.  
  75. sub dup()
  76. {   my $self = shift;
  77.     my $dup  = ref($self)->new;
  78.  
  79.     my $body = $self->{mail_inet_body} || [];
  80.     my $head = $self->{mail_inet_head};;
  81.  
  82.     $dup->{mail_inet_body} = [ @$body ];
  83.     $dup->{mail_inet_head} = $head->dup if $head;
  84.     $dup;
  85. }
  86.  
  87.  
  88. sub body(;$@)
  89. {   my $self = shift;
  90.  
  91.     return $self->{mail_inet_body} ||= []
  92.         unless @_;
  93.  
  94.     $self->{mail_inet_body} = ref $_[0] eq 'ARRAY' ? $_[0] : [ @_ ];
  95. }
  96.  
  97.  
  98. sub head         { shift->{mail_inet_head} ||= Mail::Header->new }
  99.  
  100.  
  101. sub print($)
  102. {   my $self = shift;
  103.     my $fd   = shift || \*STDOUT;
  104.  
  105.     $self->print_header($fd)
  106.        and print $fd "\n"
  107.        and $self->print_body($fd);
  108. }
  109.  
  110.  
  111. sub print_header($) { shift->head->print(@_) }
  112.  
  113. sub print_body($)
  114. {   my $self = shift;
  115.     my $fd   = shift || \*STDOUT;
  116.  
  117.     foreach my $ln (@{$self->body})
  118.     {    print $fd $ln or return 0;
  119.     }
  120.  
  121.     1;
  122. }
  123.  
  124.  
  125. sub as_string()
  126. {   my $self = shift;
  127.     $self->head->as_string . "\n" . join '', @{$self->body};
  128. }
  129.  
  130.  
  131. sub as_mbox_string($)
  132. {   my $self    = shift->dup;
  133.     my $escaped = shift;
  134.  
  135.     $self->head->delete('Content-Length');
  136.     $self->escape_from unless $escaped;
  137.     $self->as_string . "\n";
  138. }
  139.  
  140.  
  141. sub header       { shift->head->header(@_) }
  142. sub fold         { shift->head->fold(@_) }
  143. sub fold_length  { shift->head->fold_length(@_) }
  144. sub combine      { shift->head->combine(@_) }
  145.  
  146.  
  147. sub add(@)
  148. {   my $head = shift->head;
  149.     my $ret;
  150.     while(@_)
  151.     {   my ($tag, $line) = splice @_, 0, 2;
  152.         $ret = $head->add($tag, $line, -1)
  153.             or return undef;
  154.     }
  155.  
  156.     $ret;
  157. }
  158.  
  159.  
  160. sub replace(@)
  161. {   my $head = shift->head;
  162.     my $ret;
  163.  
  164.     while(@_)
  165.     {   my ($tag, $line) = splice @_, 0, 2;
  166.         $ret = $head->replace($tag, $line, 0)
  167.              or return undef;
  168.     }
  169.  
  170.     $ret;
  171. }
  172.  
  173.  
  174. sub get(@)
  175. {   my $head = shift->head;
  176.  
  177.     return map { $head->get($_) } @_
  178.         if wantarray;
  179.  
  180.     foreach my $tag (@_)
  181.     {   my $r = $head->get($tag);
  182.         return $r if defined $r;
  183.     }
  184.  
  185.     undef;
  186. }
  187.  
  188.  
  189. sub delete(@)
  190. {   my $head = shift->head;
  191.     map { $head->delete($_) } @_;
  192. }
  193.  
  194. # Undocumented; unused???
  195. sub empty()
  196. {   my $self = shift;
  197.     %$self = ();
  198.     1;
  199. }
  200.  
  201.  
  202. sub remove_sig($)
  203. {   my $body   = shift->body;
  204.     my $nlines = shift || 10;
  205.     my $start  = @$body;
  206.  
  207.     my $i    = 0;
  208.     while($i++ < $nlines && $start--)
  209.     {   next if $body->[$start] !~ /^--[ ]?[\r\n]/;
  210.  
  211.         splice @$body, $start, $i;
  212.         last;
  213.     }
  214. }
  215.  
  216.  
  217. sub sign(@)
  218. {   my ($self, %arg) = @_;
  219.     my ($sig, @sig);
  220.  
  221.     if($sig = delete $arg{File})
  222.     {   local *SIG;
  223.  
  224.         if(open(SIG, $sig))
  225.         {   local $_;
  226.             while(<SIG>) { last unless /^(--)?\s*$/ }
  227.             @sig = ($_, <SIG>, "\n");
  228.             close SIG;
  229.         }
  230.     }
  231.     elsif($sig = delete $arg{Signature})
  232.     {    @sig = ref($sig) ? @$sig : split(/\n/, $sig);
  233.     }
  234.  
  235.     if(@sig)
  236.     {   $self->remove_sig;
  237.         s/[\r\n]*$/\n/ for @sig;
  238.         push @{$self->body}, "-- \n", @sig;
  239.     }
  240.  
  241.     $self;
  242. }
  243.  
  244.  
  245. sub tidy_body()
  246. {   my $body = shift->body;
  247.  
  248.     shift @$body while @$body && $body->[0]  =~ /^\s*$/;
  249.     pop @$body   while @$body && $body->[-1] =~ /^\s*$/;
  250.     $body;
  251. }
  252.  
  253.  
  254. sub reply(@)
  255. {   my ($self, %arg) = @_;
  256.     my $class = ref $self;
  257.     my @reply;
  258.  
  259.     local *MAILHDR;
  260.     if(open(MAILHDR, "$ENV{HOME}/.mailhdr")) 
  261.     {    # User has defined a mail header template
  262.          @reply = <MAILHDR>;
  263.          close MAILHDR;
  264.     }
  265.  
  266.     my $reply = $class->new(\@reply);
  267.  
  268.     # The Subject line
  269.     my $subject = $self->get('Subject') || "";
  270.     $subject = "Re: " . $subject
  271.         if $subject =~ /\S+/ && $subject !~ /Re:/i;
  272.  
  273.     $reply->replace(Subject => $subject);
  274.  
  275.     # Locate who we are sending to
  276.     my $to = $self->get('Reply-To')
  277.           || $self->get('From')
  278.           || $self->get('Return-Path')
  279.           || "";
  280.  
  281.     my $sender = (Mail::Address->parse($to))[0];
  282.  
  283.     my $name = $sender->name;
  284.     unless(defined $name)
  285.     {    my $fr = $self->get('From');
  286.          defined $fr and $fr   = (Mail::Address->parse($fr))[0];
  287.          defined $fr and $name = $fr->name;
  288.     }
  289.  
  290.     my $indent = $arg{Indent} || ">";
  291.     if($indent =~ /\%/) 
  292.     {   my %hash = ( '%' => '%');
  293.         my @name = $name ? grep( {length $_} split /[\n\s]+/, $name) : '';
  294.  
  295.         $hash{f} = $name[0];
  296.         $hash{F} = $#name ? substr($hash{f},0,1) : $hash{f};
  297.  
  298.         $hash{l} = $#name ? $name[$#name] : "";
  299.         $hash{L} = substr($hash{l},0,1) || "";
  300.  
  301.         $hash{n} = $name || "";
  302.         $hash{I} = join "", map {substr($_,0,1)} @name;
  303.  
  304.         $indent  =~ s/\%(.)/defined $hash{$1} ? $hash{$1} : $1/eg;
  305.     }
  306.  
  307.     my $id     = $sender->address;
  308.     $reply->replace(To => $id);
  309.  
  310.     # Find addresses not to include
  311.     my $mailaddresses = $ENV{MAILADDRESSES} || "";
  312.  
  313.     my %nocc = (lc($id) => 1);
  314.     $nocc{lc $_->address} = 1
  315.         for Mail::Address->parse($reply->get('Bcc'), $mailaddresses);
  316.  
  317.     if($arg{ReplyAll})   # Who shall we copy this to
  318.     {   my %cc;
  319.         foreach my $addr (Mail::Address->parse($self->get('To'), $self->get('Cc'))) 
  320.         {   my $lc   = lc $addr->address;
  321.             $cc{$lc} = $addr->format
  322.                  unless $nocc{$lc};
  323.         }
  324.         my $cc = join ', ', values %cc;
  325.         $reply->replace(Cc => $cc);
  326.     }
  327.  
  328.     # References
  329.     my $refs    = $self->get('References') || "";
  330.     my $mid     = $self->get('Message-Id');
  331.  
  332.     $refs      .= " " . $mid if defined $mid;
  333.     $reply->replace(References => $refs);
  334.  
  335.     # In-Reply-To
  336.     my $date    = $self->get('Date');
  337.     my $inreply = "";
  338.  
  339.     if(defined $mid)
  340.     {    $inreply  = $mid;
  341.          $inreply .= ' from ' . $name if defined $name;
  342.          $inreply .= ' on '   . $date if defined $date;
  343.     }
  344.     elsif(defined $name)
  345.     {    $inreply  = $name    . "'s message";
  346.          $inreply .= "of "    . $date if defined $date;
  347.     }
  348.     $reply->replace('In-Reply-To' => $inreply);
  349.  
  350.     # Quote the body
  351.     my $body  = $reply->body;
  352.     @$body = @{$self->body};    # copy body
  353.     $reply->remove_sig;
  354.     $reply->tidy_body;
  355.     s/\A/$indent/ for @$body;
  356.  
  357.     # Add references
  358.     unshift @{$body}, (defined $name ? $name . " " : "") . "<$id> writes:\n";
  359.  
  360.     if(defined $arg{Keep} && ref $arg{Keep} eq 'ARRAY')      # Include lines
  361.     {   foreach my $keep (@{$arg{Keep}}) 
  362.         {    my $ln = $self->get($keep);
  363.              $reply->replace($keep => $ln) if defined $ln;
  364.         }
  365.     }
  366.  
  367.     if(defined $arg{Exclude} && ref $arg{Exclude} eq 'ARRAY') # Exclude lines
  368.     {    $reply->delete(@{$arg{Exclude}});
  369.     }
  370.  
  371.     $reply->head->cleanup;      # remove empty header lines
  372.     $reply;
  373. }
  374.  
  375.  
  376. sub smtpsend($@)
  377. {   my ($self, %opt) = @_;
  378.  
  379.     require Net::SMTP;
  380.     require Net::Domain;
  381.  
  382.     my $host     = $opt{Host};
  383.     my $envelope = $opt{MailFrom} || mailaddress();
  384.     my $quit     = 1;
  385.  
  386.     my ($smtp, @hello);
  387.  
  388.     push @hello, Hello => $opt{Hello}
  389.         if defined $opt{Hello};
  390.  
  391.     push @hello, Port => $opt{Port}
  392.     if exists $opt{Port};
  393.  
  394.     push @hello, Debug => $opt{Debug}
  395.     if exists $opt{Debug};
  396.  
  397.     if(!defined $host)
  398.     {   local $SIG{__DIE__};
  399.     my @hosts = qw(mailhost localhost);
  400.     unshift @hosts, split /\:/, $ENV{SMTPHOSTS}
  401.             if defined $ENV{SMTPHOSTS};
  402.  
  403.     foreach $host (@hosts)
  404.         {   $smtp = eval { Net::SMTP->new($host, @hello) };
  405.         last if defined $smtp;
  406.     }
  407.     }
  408.     elsif(ref($host) && UNIVERSAL::isa($host,'Net::SMTP'))
  409.     {   $smtp = $host;
  410.     $quit = 0;
  411.     }
  412.     else
  413.     {   local $SIG{__DIE__};
  414.     $smtp = eval { Net::SMTP->new($host, @hello) };
  415.     }
  416.  
  417.     defined $smtp or return ();
  418.  
  419.     my $head = $self->cleaned_header_dup;
  420.  
  421.     $head->delete('Bcc');
  422.  
  423.     # Who is it to
  424.  
  425.     my @rcpt = map { ref $_ ? @$_ : $_ } grep { defined } @opt{'To','Cc','Bcc'};
  426.     @rcpt    = map { $head->get($_) } qw(To Cc Bcc)
  427.     unless @rcpt;
  428.  
  429.     my @addr = map {$_->address} Mail::Address->parse(@rcpt);
  430.     @addr or return ();
  431.  
  432.     # Send it
  433.  
  434.     my $ok = $smtp->mail($envelope)
  435.           && $smtp->to(@addr)
  436.           && $smtp->data(join("", @{$head->header}, "\n", @{$self->body}));
  437.  
  438.     $quit && $smtp->quit;
  439.     $ok ? @addr : ();
  440. }
  441.  
  442.  
  443. sub send($@)
  444. {   my ($self, $type, @args) = @_;
  445.  
  446.     require Mail::Mailer;
  447.  
  448.     my $head  = $self->cleaned_header_dup;
  449.     my $mailer = Mail::Mailer->new($type, @args);
  450.  
  451.     $mailer->open($head->header_hashref);
  452.     $self->print_body($mailer);
  453.     $mailer->close;
  454. }
  455.  
  456.  
  457. sub nntppost
  458. {   my ($self, %opt) = @_;
  459.  
  460.     require Net::NNTP;
  461.  
  462.     my $groups = $self->get('Newsgroups') || "";
  463.     my @groups = split /[\s,]+/, $groups;
  464.     @groups or return ();
  465.  
  466.     my $head   = $self->cleaned_header_dup;
  467.  
  468.     # Remove these incase the NNTP host decides to mail as well as me
  469.     $head->delete(qw(To Cc Bcc)); 
  470.  
  471.     my $news;
  472.     my $quit   = 1;
  473.  
  474.     my $host   = $opt{Host};
  475.     if(ref($host) && UNIVERSAL::isa($host,'Net::NNTP'))
  476.     {   $news = $host;
  477.     $quit = 0;
  478.     }
  479.     else
  480.     {   my @opt = $opt{Host};
  481.  
  482.     push @opt, Port => $opt{Port}
  483.         if exists $opt{Port};
  484.  
  485.     push @opt, Debug => $opt{Debug}
  486.         if exists $opt{Debug};
  487.  
  488.     $news = Net::NNTP->new(@opt)
  489.         or return ();
  490.     }
  491.  
  492.     $news->post(@{$head->header}, "\n", @{$self->body});
  493.     my $rc = $news->code;
  494.  
  495.     $news->quit if $quit;
  496.  
  497.     $rc == 240 ? @groups : ();
  498. }
  499.  
  500.  
  501. sub escape_from
  502. {   my $body = shift->body;
  503.     scalar grep { s/\A(>*From) />$1 /o } @$body;
  504. }
  505.  
  506.  
  507.  
  508. sub unescape_from
  509. {   my $body = shift->body;
  510.     scalar grep { s/\A>(>*From) /$1 /o } @$body;
  511. }
  512.  
  513. # Don't tell people it exists
  514. sub cleaned_header_dup()
  515. {   my $head = shift->head->dup;
  516.  
  517.     $head->delete('From '); # Just in case :-)
  518.  
  519.     # An original message should not have any Received lines
  520.     $head->delete('Received');
  521.  
  522.     $head->replace('X-Mailer', "Perl5 Mail::Internet v".$Mail::Internet::VERSION)
  523.         unless $head->count('X-Mailer');
  524.  
  525.     my $name = eval {local $SIG{__DIE__}; (getpwuid($>))[6]} || $ENV{NAME} ||"";
  526.  
  527.     while($name =~ s/\([^\(\)]*\)//) { 1; }
  528.     
  529.     # Strip extra fields: adduser-generated usernames have multiple comma
  530.     # seperated fields, only the first of which should be used to prevent
  531.     # accidental exposure of system-local information like phone numbers/
  532.     # room numbers.
  533.     $name = (split /,/, $name)[0];
  534.  
  535.     if($name =~ /[^\w\s]/)
  536.     {   $name =~ s/"/\"/g;
  537.     $name = '"' . $name . '"';
  538.     }
  539.  
  540.     my $from = sprintf "%s <%s>", $name, mailaddress();
  541.     $from =~ s/\s{2,}/ /g;
  542.  
  543.     foreach my $tag (qw(From Sender))
  544.     {   $head->get($tag) or $head->add($tag, $from);
  545.     }
  546.  
  547.     $head;
  548. }
  549.  
  550. 1;
  551.